Shareware Grab Bag/Shareware Grab Bag.iso/090/byt86oct.arc/ALLOC.ARC/ALLOC3.MOD

Text File | 1985-07-12 | 11KB | 395 lines

IMPLEMENTATION MODULE Alloc3;

(* A storage allocator that tries to be safe about freed blocks.
   It uses "handles" (pointers to pointers) to keep track of blocks.
   It also compacts space, and allows resizing.
   Copyright 1986 by Jonathan Amsterdam.  All Rights Reserved. *)

FROM SYSTEM IMPORT WORD, ADDRESS, TSIZE, ADR;
FROM MachineSpecific IMPORT getHeapBottom, getHeapTop, bytesPerWord,
    address, cardinal, addrLessThan, writeAddress, addWords, subtractWords,
    maxAddress;
FROM MyTerminal IMPORT fatal, WriteLnString, WriteCard,
    WriteString, WriteLn;

CONST maxIndex = 32767;
      nMasters = 10;  (* number of masters to allocate each time more needed *)

TYPE handle = POINTER TO blockPtr;
     blockPtr = POINTER TO block;
     block = RECORD
         size:CARDINAL;  (* not including header *)
         CASE BOOLEAN OF
            TRUE: nextBlock: blockPtr;
         |  FALSE: contents:ARRAY[0..maxIndex] OF WORD;
         END;
         END;

VAR heapBottom,         (* first word in heap *)
    heapTop,            (* last word in heap *)
    masterPtr,            (* next available master *)
    masterBottom,        (* lowest point of masters section *)
    firstHandle:ADDRESS;    (* first handle ever allocated *)
    freeList:blockPtr;        (* start of free list *)
    blockHeaderWords,        (* # of words in a block header *)
    minBlockSize,        (* smallest value for size field of a block *)
    masterWords:CARDINAL;   (* # of words occupied by a master pointer *)

PROCEDURE init;
VAR heapWords:CARDINAL;
BEGIN
    heapBottom := getHeapBottom();
    heapTop := getHeapTop();
    blockHeaderWords := TSIZE(CARDINAL);
    masterWords := TSIZE(ADDRESS);
    minBlockSize := TSIZE(blockPtr);
    freeList := blockPtr(heapBottom);
    heapWords := cardinal(heapTop - heapBottom + address(1)) DIV bytesPerWord;
    freeList^.size := heapWords - blockHeaderWords;
    freeList^.nextBlock := NIL;
    masterBottom := oneAfter(freeList);
    firstHandle := subtractWords(masterBottom, masterWords);
    masterPtr := firstHandle;
    moreMasters;
END init;

PROCEDURE oneAfter(blockp:blockPtr):ADDRESS;
(* Returns the address of 1 higher than block *)
BEGIN
    RETURN addWords(blockp, blockp^.size + blockHeaderWords);
END oneAfter;


PROCEDURE blockSize(h:handle):CARDINAL;
BEGIN
    RETURN h^^.size;
END blockSize;

PROCEDURE getWord(h:handle; n:CARDINAL):WORD;
BEGIN
    accessCheck(h, n);
    RETURN h^^.contents[n];
END getWord;

PROCEDURE setWord(h:handle; n:CARDINAL; w:WORD);
BEGIN
    accessCheck(h, n);
    h^^.contents[n] := w;
END setWord;

PROCEDURE accessCheck(h:handle; n:CARDINAL);
BEGIN
    IF h^ = NIL THEN
    fatal('attempt to access a freed block');
    ELSIF n >= h^^.size THEN
    fatal('access out of bounds');
    END;
END accessCheck;

PROCEDURE allocate(nWords:CARDINAL):handle;
VAR master:handle;
BEGIN
    master := allocMaster();
    IF master <> NIL THEN
    master^ := NIL;  (* do this first to prevent this master from
                being involved in compaction *)
    master^ := allocBlock(nWords);
    END;
    RETURN master;
END allocate;

PROCEDURE allocBlock(nWords:CARDINAL):blockPtr;
VAR blockp:blockPtr;
BEGIN
    blockp := allocB(nWords);
    IF blockp = NIL THEN
    compact;
    blockp := allocB(nWords);
    END;
    RETURN blockp;
END allocBlock;

PROCEDURE allocB(nWords:CARDINAL):blockPtr;
VAR currBlock, prevBlock, newBlock:blockPtr;
    blockWords:CARDINAL;
BEGIN
    IF nWords < minBlockSize THEN
    nWords := minBlockSize; (* can't allocate a smaller block than this *)
    END;
    blockWords := nWords + blockHeaderWords;
    currBlock := freeList;
    prevBlock := NIL;
    WHILE currBlock <> NIL DO
    IF blockWords + minBlockSize <= currBlock^.size THEN
        (* split the block into two, returning the 1st part *)
        newBlock := addWords(currBlock, blockWords);
        newBlock^.size := currBlock^.size - blockWords;
        newBlock^.nextBlock := currBlock^.nextBlock;
        link(prevBlock, newBlock);
        currBlock^.size := nWords;
        RETURN currBlock;
    ELSIF nWords <= currBlock^.size THEN (* return the whole block *)
        link(prevBlock, currBlock^.nextBlock);
        RETURN currBlock;
    END;
    prevBlock := currBlock;
    currBlock := currBlock^.nextBlock;
    END (* WHILE *);
    RETURN NIL;
END allocB;

PROCEDURE allocMaster():handle;
(* The strategy here is as follows:
    1. If there is enough room between masterBottom and masterPtr to allocate
       a master, do so.
    2. If that fails, compact and allocate more masters, then try again.
*)
BEGIN
    IF addrLessThan(masterPtr, masterBottom) THEN
    compact;
    moreMasters;
    END;
    IF addrLessThan(masterPtr, masterBottom) THEN
    RETURN NIL;
    ELSE
    masterPtr := subtractWords(masterPtr, masterWords);
    RETURN addWords(masterPtr, masterWords);
    END;
END allocMaster;

PROCEDURE moreMasters;
(* Get highest block.  If its top isn't contiguous with the masters already
   allocated, do nothing.
   Else, try to allocate nMasters from its top; if it's too
   small, allocate it all.
*)
VAR prev, high:blockPtr;
    nWords:CARDINAL;
BEGIN
    nWords := nMasters * masterWords;
    IF freeList <> NIL THEN
    high := freeList;
    prev := NIL;
    WHILE high^.nextBlock <> NIL DO
        prev := high;
        high := high^.nextBlock;
    END;
    (* high now points to highest block *)
    IF oneAfter(high) = masterBottom THEN
        (* top of block is contiguous with masters *)
        IF high^.size >= minBlockSize + nWords THEN
        (* chop off nWords words from high *)
        DEC(high^.size, nWords);
        masterBottom := oneAfter(high);
        ELSIF high^.size >= minBlockSize + masterWords THEN
        (* chop of enough for one master *)
        DEC(high^.size, masterWords);
        masterBottom := oneAfter(high);
        ELSE
        (* detach whole block *)
        link(prev, high^.nextBlock);
        masterBottom := high;
        END;
    END;
    END;
END moreMasters;


PROCEDURE free(VAR freeBlock:handle);
BEGIN
    freeBlk(freeBlock^);
    freeBlock^:= NIL;
    freeBlock := NIL;
END free;

PROCEDURE freeBlk(freeBlock:blockPtr);
VAR currBlock, prevBlock:blockPtr;
BEGIN
    IF NOT addrBetween(heapBottom, freeBlock, masterBottom) THEN
    fatal("free: block not in heap");
    ELSIF freeBlock = NIL THEN
    fatal("free: attempt to free an already freed block");
    ELSE
    currBlock := freeList;
    prevBlock := NIL;
    WHILE (currBlock <> NIL) AND addrLessThan(currBlock, freeBlock) DO
        prevBlock := currBlock;
        currBlock := currBlock^.nextBlock;
    END;
    IF currBlock = NIL THEN
        freeBlock^.nextBlock := NIL;
        link(prevBlock, freeBlock);
    ELSE  (* freeBlock belongs just before currBlock *)
        freeBlock^.nextBlock := currBlock;
        link(prevBlock, freeBlock);
    END;
    tryToMerge(prevBlock, freeBlock, currBlock);
    END;
END freeBlk;

PROCEDURE tryToMerge(lowBlock, middleBlock, highBlock:blockPtr);
BEGIN
    IF adjacent(middleBlock, highBlock) THEN
    merge(middleBlock, highBlock);
    END;
    IF adjacent(lowBlock, middleBlock) THEN (* this should be impossible *)
    merge(lowBlock, middleBlock);
    END;
END tryToMerge;

PROCEDURE adjacent(lowerBlock, higherBlock:blockPtr):BOOLEAN;
BEGIN
  RETURN
    (lowerBlock <> NIL) AND
    (higherBlock <> NIL) AND
    (oneAfter(lowerBlock) = higherBlock);
END adjacent;

PROCEDURE merge(lowerBlock, higherBlock:blockPtr);
BEGIN
    INC(lowerBlock^.size, higherBlock^.size + blockHeaderWords);
    lowerBlock^.nextBlock := higherBlock^.nextBlock;
END merge;

PROCEDURE resize(h:handle; nWords:CARDINAL);
VAR blockp:blockPtr;
BEGIN
    blockp := allocBlock(nWords);
    IF blockp <> NIL THEN
    copyFromTo(h^, blockp, nWords);
    freeBlk(h^);
    h^ := blockp;
    END;
END resize;


PROCEDURE compact;
(* compact blocks to low end of heap *)
VAR lowPoint:blockPtr;
    lowestHandle:handle;
BEGIN
  IF freeList <> NIL THEN
    lowPoint := heapBottom;
    WHILE findLowestHandleNotLowerThan(lowPoint, lowestHandle) DO
    IF lowestHandle^ <> lowPoint THEN
        lowPoint^.size := lowestHandle^^.size;
        copyFromTo(lowestHandle^, lowPoint, lowPoint^.size);
        lowestHandle^ := lowPoint;
    END;
    lowPoint := oneAfter(lowPoint);
    END;
    (* now fix freelist *)
    freeList := lowPoint;
    freeList^.size := (cardinal(masterBottom-ADDRESS(freeList))
                DIV bytesPerWord) - blockHeaderWords;
    freeList^.nextBlock := NIL;
  END;
END compact;

PROCEDURE findLowestHandleNotLowerThan(low:blockPtr;VAR min:handle):BOOLEAN;
VAR h:handle;
    return:BOOLEAN;
    bp: blockPtr;
BEGIN
    h := firstHandle;
    bp := blockPtr(maxAddress);
    min := ADR(bp);
    return := FALSE;
    WHILE addrLessThan(masterPtr, h) DO
    IF (NOT addrLessThan(min^, h^)) AND (NOT addrLessThan(h^, low)) THEN
        min := h;
        return := TRUE;
    END;
    h := subtractWords(h, masterWords);
    END;
    RETURN return;
END findLowestHandleNotLowerThan;

PROCEDURE copyFromTo(source, dest:blockPtr; nWords:CARDINAL);
VAR i:CARDINAL;
BEGIN
    IF source^.size < nWords THEN
    nWords := source^.size;
    END;
    FOR i := 0 TO nWords-1 DO
    dest^.contents[i] := source^.contents[i];
    END;
END copyFromTo;

PROCEDURE link(prevBlock, linkBlock:blockPtr);
BEGIN
    IF prevBlock = NIL THEN
    freeList := linkBlock;
    ELSE
    prevBlock^.nextBlock := linkBlock;
    END;
END link;

PROCEDURE addrBetween(low, middle, high:ADDRESS):BOOLEAN;
BEGIN
    RETURN (addrLessThan(low, middle) OR (low = middle)) AND
       (addrLessThan(middle, high) OR (middle = high));
END addrBetween;

    (*** debugging stuff ***)

PROCEDURE getFreeList():handle;
(* for debugging only *)
BEGIN
    RETURN handle(freeList);
END getFreeList;

PROCEDURE writeMap;
VAR lowestFree, lowPoint:blockPtr;
    lowestAlloc:handle;

    PROCEDURE writeFree;
    BEGIN
    WriteString("Free  ");
    writeRelAddress(lowestFree);
    WriteCard(lowestFree^.size, 4);
    WriteLnString(" words");
    END writeFree;

BEGIN    (* writeMap *)
    WriteLn;
    lowestFree := freeList;
    lowPoint := heapBottom;
    WHILE findLowestHandleNotLowerThan(lowPoint, lowestAlloc) DO
    WHILE addrLessThan(lowestFree, lowestAlloc^) AND (lowestFree <> NIL) DO
        writeFree;
        lowestFree := lowestFree^.nextBlock;
    END;
    WriteString("Alloc ");
    writeRelAddress(lowestAlloc^);
    WriteCard(lowestAlloc^^.size, 4);
    WriteLnString(" words");
    lowPoint := oneAfter(lowestAlloc^);
    END;
    WHILE lowestFree <> NIL DO
    writeFree;
    lowestFree := lowestFree^.nextBlock;
    END;
    WriteLn;
    WriteString("firstHandle:  ");
    writeRelAddress(firstHandle); WriteLn;
    WriteString("masterPtr:    ");
    writeRelAddress(masterPtr); WriteLn;
    WriteString("masterBottom: ");
    writeRelAddress(masterBottom); WriteLn;
END writeMap;

PROCEDURE writeRelAddress(a:ADDRESS);
BEGIN
    WriteCard(cardinal(a - heapBottom), 4);
END writeRelAddress;

BEGIN
    init;
END Alloc3.
ddress(a:ADDRESS);
BEGIN
    WriteCard(cardinal(a - heapBottom), 4);
END writeRelAddress;

BEGI